;;; test-heap.ss  --  Jens Axel Soegaard

(require "../heap.ss"
         (lib "list.ss"))

(define n 10000)     ; use 100 000 for a time comparisons

;;; TEST

; test/time : heap-unit integer -> boolean
;   make heap-of-integers using the given heap-unit
;   use it to heap-sort the list (1 2 ... n)
;   compare it with (1 2 ... n)
;   return boolean value indicating, whether the sort was ok
;   print timings
;   NB: This test uses merge in order to implement list->heap
;       This test uses delete-min and find-min in order to implement heap->list

(define (test/time heap@ n)
  (define integer-heap@ (instantiate-heap heap@ integers@))
  (test/time-helper integer-heap@ n))

(define (test/time-bootstrapped heap@ n)
  (define integer-heap@ (bootstrap-heap heap@ integers@))
  (test/time-helper integer-heap@ n))

(define (test/time-explicit-min heap@ n)
  (define integer-heap@ (explicit-min-heap heap@ integers@))
  (test/time-helper integer-heap@ n))

(define (test/time-helper integer-heap@ n)
  (use-heap integer-heap@)
  
  ; list->heap : list -> heap
  ;  T[list->heap] = O(log n), if T[merge] = O(log n)
  ; ref: [Oka, exercise 3.3]
  (define (list->heap l)
    (define (make-singleton-heap e)
      (insert empty e))
    
    (define (merge-heap-pairs hl)
      (cond
        [(null? hl)        empty]
        [(null? (rest hl)) (first hl)]
        [else              (merge (merge (first hl) (second hl))
                                  (merge-heap-pairs (rest (rest hl))))]))
    
    (merge-heap-pairs (map make-singleton-heap l)))
  
  ;(define (list->heap l)
  ;  (define (loop h l)
  ;    (if (empty? l)
  ;        h
  ;        (loop (insert (first l) h) (rest l))))
  ;  (loop empty l))
  
  (define (heap->list h)
    (define (loop h l)
      (if (empty? h)
          l
          (loop (delete-min h) (cons (find-min h) l))))
    (loop h '()))
  
  (define (interval m n)
    (if (<= m n)
        (cons m (interval (add1 m) n))
        '()))

  ; shuffle-list is from the card collection
  (define shuffle-list 
   (lambda (l c)
     (if (zero? c)
	 l
	 (let-values ([(a b)
		       (let ([half (floor (/ (length l) 2))])
			 (values
			  (let loop ([l l][n half])
			    (if (zero? n)
				null
				(cons (car l) (loop (cdr l) (sub1 n)))))
			  (list-tail l half)))])
	   (shuffle-list
	    (let loop ([a a][b b][l null])
	      (cond
	       [(null? a) (append (reverse b) l)]
	       [(null? b) (append (reverse a) l)]
	       [(zero? (random 2))
		(loop (cdr a) b (cons (car a) l))]
	       [else
		(loop a (cdr b) (cons (car b) l))]))
	    (sub1 c))))))
  
  (define (heap-test)
    (define l1 (reverse (interval 1 n)))
    (define l3 (shuffle-list l1 7))
    (define l2 (heap->list (list->heap l3)))
    (equal? l1 l2))
  
  (collect-garbage)
  (time (heap-test)))


;;; NORMAL HEAPS


'leftist-heap-test
(test/time leftist-heap@ n)
'binomial-heap-test
(test/time binomial-heap@ n)
'pairing-heap-test
(test/time pairing-heap@  n)
'splay-heap-test
(test/time splay-heap@  n)
'lazy-binomial-heap-test
(test/time lazy-binomial-heap@  n)
'lazy-pairing-heap-test
(test/time lazy-pairing-heap@  n)
'skew-binomial-heap-test
(test/time skew-binomial-heap@  n)


;;; BOOTSTRAPPED HEAPS

'bootstrapped-leftist-heap-test
(test/time-bootstrapped leftist-heap@ n)
'bootstrapped-lazy-binomial-heap-test
(test/time-bootstrapped lazy-binomial-heap@ n)
'bootstrapped-skew-binomial-heap-test
(test/time-bootstrapped skew-binomial-heap@ n)
'bootstrapped-lazy-pairing-heap-test    
(test/time-bootstrapped lazy-pairing-heap@ n)


;;; The EXPLICT-MIN functor

'explicit-min-leftist-heap-test
(test/time-explicit-min  leftist-heap@ n)
'explicit-min-binomial-heap-test
(test/time-explicit-min  binomial-heap@ n)


; (require (lib "../priority-queue.ss" "galore"))
;(define pq@ (instantiate-priority-queue leftist-heap@ integers@))
;(define-values/invoke-unit/sig priority-queue^ pq@)
;
;(define p empty)
;(define p1 (insert p  'jens 1))
;(define p2 (insert p1 'axel 2))
;(find-min p1)
;(find-min p2)
;(find-min (delete-min p2))
;(find-min (delete-min p2))
;
